Shareware Super Platinum 8/Shareware Super Platinum 8.iso/mac/PROGTOOL/EUPHOR10.ZIP;1/DISPLAY.E

Text File | 1993-06-09 | 7.8 KB | 350 lines

-- display.e
-- graphics, sound and text display on screen
global sequence ship

global sequence ds -- Enterprise deflectors

global sequence ts -- Enterprise torpedos

global sequence ps -- Enterprise anti-matter pods (roughed in)

global function nkl()
-- number of Klingons left
    return nobj[G_SK] + nobj[G_BK] + nobj[G_JM]
end function

type negative_atom(atom x)
    return x <= 0
end type

global procedure p_energy(negative_atom delta)
-- print Enterprise energy
    atom energy

    energy = f[ENTERPRISE][F_EN] + delta
    f[ENTERPRISE][F_EN] = energy
    if energy < 0 then
    energy = 0
    gameover = TRUE
    end if
    position(WARP_LINE, 74)
    set_bk_color(WHITE)
    if energy < 5000 then
    set_color(RED+BLINKING)
    else
    set_color(BLACK)
    end if
    printf(CRT, "%d    ", floor(energy))
end procedure

global procedure msg(sequence text)
-- print a message on the bottom line
    set_bk_color(WHITE)
    set_color(RED)
    position(MSG_LINE, 16)
    puts(CRT, BLANK_LINE[1..50])
    position(MSG_LINE, 16)
    puts(CRT, text)
end procedure

global procedure show_warp()
-- show current speed (with warning)
    set_bk_color(WHITE)
    set_color(BLACK)
    position(WARP_LINE, 3)
    puts(CRT, "WARP:")
    if curwarp > wlimit then
    set_color(RED+BLINKING)
    end if
    printf(CRT, "%d", curwarp)
end procedure

constant warp_time = {0, 20, 4.5, 1.5, .67, .25}

global procedure setwarp(warp new)
-- establish a new warp speed for the Enterprise

    if new != curwarp then
    wait[TASK_EMOVE] = warp_time[new+1]
    eat[TASK_EMOVE] = (5-new)/20 + 0.05
    sched(TASK_EMOVE, wait[TASK_EMOVE])
    curwarp = new
    show_warp()
    end if
end procedure

global procedure gtext()
-- print text portion of galaxy scan
    set_bk_color(BLUE)
    position(1, 36)
    set_color(LIGHT_RED)
    puts(CRT, "C ")
    set_color(BROWN)
    puts(CRT, "P ")
    set_color(YELLOW)
    puts(CRT, "B")
    set_color(WHITE)
    position(2, 7)
    for i = 1 to 7 do
    printf(CRT, "%8d", i)
    end for
    for i = 1 to 7 do
    position(2*i + 1, 9)
    printf(CRT, "%d.", i)
    end for
    position(17, 35)
    set_color(BRIGHT_WHITE)
    printf(CRT, "C: %d ", nkl())
    position(18,22)
    set_color(WHITE)
    printf(CRT, "Planets: %d   BASIC: %d", {nobj[G_PL], nobj[G_RM]})
    if rstat = TRUCE then
    puts(CRT, " TRUCE   ")
    elsif rstat = HOSTILE then
    puts(CRT, " HOSTILE ")
    else
    puts(CRT, " CLOAKING")
    end if
    position(19,22)
    printf(CRT, "Bases: %d     Fortran: %d ", {nobj[G_BS], nobj[G_TH]})
end procedure

function g_screen_pos(g_index qrow, g_index qcol)
-- compute position on screen to display a galaxy scan quadrant
    return {4 + qcol * 8, qrow * 2 + 1}
end function

global procedure gquad(g_index qrow, g_index qcol)
-- print one galaxy scan quadrant

    positive_int nk, np, nb
    sequence quad_info
    screen_pos gpos

    gpos = g_screen_pos(qrow, qcol)
    position(gpos[2], gpos[1])
    quad_info = g[qrow][qcol]
    if quad_info[1] then
    nk = quad_info[G_SK] + quad_info[G_BK] + quad_info[G_JM]
    np = quad_info[G_PL]
    nb = quad_info[G_BS]
    set_color(LIGHT_RED)
    printf(CRT, "%d ", nk)
    set_color(BROWN)
    printf(CRT, "%d ", np)
    set_color(YELLOW)
    printf(CRT, "%d",  nb)
    set_color(WHITE)
    else
    puts(CRT, "*****")
    end if
end procedure

global procedure upg(g_index qrow, g_index qcol)
-- update galaxy scan quadrant
    if scanon then
    set_bk_color(BLUE)
    set_color(WHITE)
    gquad(qrow, qcol)
    end if
end procedure

sequence prev_box
prev_box = {}

global procedure gsbox(g_index qrow, g_index qcol)
-- indicate current quadrant on galaxy scan
    screen_pos gpos

    if scanon then
    set_bk_color(BLUE)
    if length(prev_box) = 2 then
        -- clear the previous "box" (could be gone already)
        position(prev_box[2], prev_box[1]-1)
        puts(CRT, ' ')
        position(prev_box[2], prev_box[1]+5)
        puts(CRT, ' ')
    end if
    set_color(WHITE)
    gquad(qrow, qcol)
    gpos = g_screen_pos(qrow, qcol)
    position(gpos[2], gpos[1]-1)
    set_color(BRIGHT_WHITE)
    puts(CRT, '[')
    position(gpos[2], gpos[1]+5)
    puts(CRT, ']')
    prev_box = gpos
    end if
end procedure

global procedure dsyms()
-- print docking symbols for planets and bases
    screen_pos gpos

    return  -- for now

    for i = 1 to PROWS do
    gpos = g_screen_pos(pb[i][P_QR], pb[i][P_QC])
    position(gpos[2], gpos[1])
    puts(CRT, ' ')
    end for

    for i = 1 to PROWS do
    if pb[i][P_EXIST] = DOCKED_WITH then
            --- TO BE CONTINUED
    end if
    end for

    for i = 1 to PROWS do
    if pb[i][P_EXIST] = NEVER_DOCKED then

    end if
    end for
end procedure

global procedure wtext()
-- print torpedos, pods, deflectors in text window
    set_bk_color(WHITE)
    set_color(BLACK)
    position(WARP_LINE, 34)
    printf(CRT, "%s %s ", {ts, ds, ps}) -- don't show pods yet
end procedure

global procedure stext()
-- print text window info
    position(QUAD_LINE, 1)
    set_bk_color(CYAN)
    set_color(MAGENTA)
    printf(CRT,
"--------------------------------- QUADRANT %d.%d ---------------------------------"
       ,{qrow, qcol})
    set_bk_color(WHITE)
    set_color(BLACK)
    show_warp()
    wtext()
    position(WARP_LINE, 67)
    printf(CRT, "ENERGY:%d    ", floor(f[ENTERPRISE][F_EN]))
    position(CMD_LINE, 3)
    puts(CRT, "COMMAND(1-8 w p t g $ @ x): ")
end procedure

procedure pxx(valid_f_row row)
-- print a base or planet
    h_coord x
    v_coord y

    x = f[row][F_X]
    y = f[row][F_Y]
    if f[row][F_TYPE] = G_PL then
    write_screen(x, y, PLANET_TOP)
    write_screen(x, y+1, PLANET_MIDDLE)
    write_screen(x, y+2, PLANET_BOTTOM)
    else
    write_screen(x, y, BASE)
    write_screen(x, y+1, BASE)
    end if
end procedure

procedure p_ship(valid_f_row row)
-- reprint a ship to get color
    h_coord x
    v_coord y
    object_type t
    sequence shape

    x = f[row][F_X]
    y = f[row][F_Y]
    t = f[row][F_TYPE]
    shape = read_screen({x, length(ship[t][1])},  y)
    write_screen(x, y, shape)
end procedure

procedure refresh_obj()
-- reprint objects with correct color after a galaxy scan
    for i = 1 to fnext-1 do
    if f[i][F_TYPE] = G_BS or f[i][F_TYPE] = G_PL then
        pxx(i)
    elsif f[i][F_TYPE] then
        p_ship(i)
    end if
    end for
end procedure

global procedure setg1()
-- end display of galaxy scan
    if scanon then
    scanon = FALSE
    ShowScreen()
    refresh_obj()
    end if
end procedure


constant PBP0 = 4

global procedure pobj()
-- print objects in a new quadrant
    h_coord x
    v_coord y
    sequence c
    positive_int len, pbi
    object_type t

    set_bk_color(BLACK)
    set_color(WHITE)
    BlankScreen(TRUE)

    -- print stars
    for i = 1 to 15 do
    write_screen(rand(HSIZE), rand(VSIZE), STAR)
    end for

    -- print planets and bases
    pbi = PBP0 - 1
    for row = 2 to fr1 - 1 do
    if row = fb1 then
        pbi = 0
    end if
    while TRUE do
        pbi = pbi + 1
        if pb[pbi][P_EXIST] != DESTROYED then
        if pb[pbi][P_QR] = qrow then
            if pb[pbi][P_QC] = qcol then
            x = pb[pbi][P_X]
            y = pb[pbi][P_Y]
            f[row][F_X] = x
            f[row][F_Y] = y
            f[row][F_PBX] = pbi
            exit
            end if
        end if
        end if
    end while
    pxx(row)
    end for

    -- print ships
    for row = fr1 to fnext-1 do
    len = length(ship[f[row][F_TYPE]][1])
    while TRUE do
        -- look for an empty place to put the ship
        x = rand(HSIZE - len) + 1
        y = rand(VSIZE - 2) + 1
        c = read_screen({x, len}, y)
        if not find(FALSE, c = ' ' or c = STAR) then
        exit
        end if
    end while
    f[row][F_UNDER] = c
    f[row][F_X] = x
    f[row][F_Y] = y
    t = f[row][F_TYPE]
    if x < f[ENTERPRISE][F_X] then
        c = ship[t][2]
    else
        c = ship[t][1]
    end if
    write_screen(x, y, c)
    end for
end procedure